Developer CD Series 1993…stman Always Clicks Twice/ADC Developer CD (1993-01) (''The Postman Always Clicks Twice'')_iso/Dev.CD 199301.iso/Development Platforms/LISP Related/LISP Goodies/McCartney-library 1.1/CODE/oodles-files/GWorld-view-extensions.lisp

Text File | 1992-09-02 | 5.1 KB | 155 lines | [TEXT/CCL2]

;;; GWorld-view-extensions.lisp
;;;
;;; Paul McCartney, Spring 1992
;;;
;;; Copyright © 1992 Paul McCartney.  All Rights Reserved.
;;;
;;; Washington University Medical Informatics Training Program
;;;
;;; DESCRIPTION:
;;;
;;; This is a simple extension for using GWorld offscreen graphics
;;; provided by Michael S. Engber in his "oodles-of-utils" package.
;;;
;;; USE:
;;;
;;; *GW-offscreen-view*       -  the offscreen view used by this module
;;;
;;; GW-extensions-init        -  initialize this module
;;;
;;; GW-extensions-destroy     -  destroy data local to this module
;;;
;;; with-GWorld-no-colorization -
;;;      A macro for offscreen drawing.  All things drawn inside this
;;;      macro and focused to "*GW-offscreen-view*" are drawn offscreen
;;;      and transfered instantaneously to the screen when the macro exits.
;;;      The colors are NOT colorized (i.e. copybits does not change the
;;;      colors between offscreen and onscreen).  See example below.
;;;
;;; make-GW-point             -  translate the onscreen view's coordinates
;;;                              to the offscreen view's coordinates.
;;;                              All graphics calls should use this function
;;;                              to compute point coordinates.
;;; HISTORY:
;;;
;;; 6/29/92  Created.  - PM
;;;

(in-package :oou)

(require :GWorld-view)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (export '(with-GWorld-no-colorization GW-extensions-init GW-extensions-destroy make-GW-point
            *GW-offscreen-view*)
          :oou))


(defvar *GW-offscreen-view*)
(defvar *GW-topleft*)


;;; Initialize a large offscreen GWorld for general purpose drawing.
;;;
(defun GW-extensions-init (&optional (size (get-largest-screen-size)))
  (setf *GW-offscreen-view*
        (make-instance 'GWorld-view
          :GW-depth 0
          :view-position #@(0 0)
          :view-size size))
  (GW-alloc *GW-offscreen-view*) )


;;; Destroy the offscreen GWorld.
;;;
(defun GW-extensions-destroy ()
  (GW-free *GW-offscreen-view*))


;;; Return the largest horizontal and vertical screen sizes encoded as a point.
;;; Note that this doesn't necessarily correspond to one screen, each of h and v is
;;; the largest of all the screens.
;;;
(defun get-largest-screen-size ()
  (let ((size-h 0)
        (size-v 0))
    (do ((gd (#_GetDeviceList) (#_GetNextDevice gd)))
        ((%null-ptr-p gd) (make-point size-h size-v))
      (with-dereferenced-handles ((gd1 gd))
        (let* ((gd-rect (pref gd1 Gdevice.gdRect))
               (gd-size-h (- (rref gd-rect rect.right) (rref gd-rect rect.left)))
               (gd-size-v (- (rref gd-rect rect.bottom) (rref gd-rect rect.top))))
          (if (> gd-size-h size-h)
            (setf size-h gd-size-h))
          (if (> gd-size-v size-v)
            (setf size-v gd-size-v)) )) )))


;;; A macro for offscreen drawing.  All things drawn inside this
;;; macro and focused to "*GW-offscreen-view*" are drawn offscreen
;;; and transfered instantaneously to the screen when the macro exits.
;;; The colors are NOT colorized (i.e. copybits does not change the
;;; colors between offscreen and onscreen).  See example below.
;;;
(defmacro with-GWorld-no-colorization ((view left top right bottom &optional (mode #$srcCopy)) &body body)
  `(rlet ((to-rect :rect :left ,left :top ,top :right ,right :bottom ,bottom)
          (from-rect :rect :left 0 :top 0 :right (- ,right ,left) :bottom (- ,bottom ,top)))
     (without-interrupts
      (setf *GW-topleft* (make-point ,left ,top))

        (with-focused-view *GW-offscreen-view*
          (with-back-color (rgb-to-color (rref (wptr ,view) cgrafport.rgbbkcolor))
            (with-fore-color (rgb-to-color (rref (wptr ,view) cgrafport.rgbfgcolor))
              (require-trap #_EraseRect from-rect)
              ,@body)))
        (with-locked-GWorld-view *GW-offscreen-view*
          (with-focused-view ,view
            (with-fore-color *black-color*
              (with-back-color *white-color*
                (with-pointers ((sb (rref (wptr *GW-offscreen-view*)
                                          :GrafPort.portBits))
                                (db (rref (wptr ,view) :GrafPort.portBits)))
                  (require-trap #_CopyBits sb db from-rect to-rect ,mode (%null-ptr))))))) )))


(defun make-GW-point (h &optional v)
  (if v
    (subtract-points (make-point h v) *GW-topleft*)
    (subtract-points h *GW-topleft*)))


(provide :GWorld-view-extensions)


#|
; Example

(in-package :oou)

(defvar w)
(setf w (make-instance 'window
          :view-position #@(50 50)
          :view-size #@(200 200)
          :color-p t))

(set-back-color w *black-color*)

(defun draw-random-ovals (n)
  (with-GWorld-no-colorization (w 0 0 200 200)
    (dotimes (i n)
      (let* ((topleft (make-point (random 200) (random 200)))
             (bottomright (add-points topleft
                                      (make-point (random 50) (random 50)))))
        (with-fore-color (random *white-color*)
          (rlet ((r :rect :topleft topleft :bottomright bottomright))
            (#_PaintOval r)) )))))


(dotimes (i 5)
  (draw-random-ovals 50))

;;; Do this next line when you are finished with the demo
;;;
; (GW-extensions-destroy)

|#